{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Majalan.Base.NoteList
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- NoteList - notes and rests with duration in bars.
--
--------------------------------------------------------------------------------

module Majalan.Base.NoteList
  ( 
    NoteList
  , noteList
  , noteListB1
  , noteListB2
  , noteListB3
  , noteListB4
  , noteListB5

  , noteListDuration

  , bar

  ) where


import Majalan.Base.Advance
import Majalan.Base.Behavior
import Majalan.Base.Event
import Majalan.Base.EventList
import Majalan.Base.Internal.Base
import Majalan.Base.Internal.Utils

import Control.Applicative
import Data.Monoid

-- Drn - symbolic (and polymorphic) or fixed to Beat?


-- Beat is quarter-note
--
data Elt pch = R Beat | N Beat pch
  deriving (Eq,Ord,Show)

instance Functor Elt where
  fmap f (N d p)  = N d (f p)
  fmap _ (R d)    = R d


  

-- To allow tempo changes Bar should be labelled with quarter 
-- note length.
--
data Bar pch = Bar 
    { bar_bpm      :: BPM
    , bar_notes    :: [Elt pch] 
    }

instance Functor Bar where
  fmap f = (\s a -> s { bar_notes =  map (fmap f) a }) <*> bar_notes



newtype NoteList pch = NoteList { getNoteList :: H (Bar pch) }

instance Functor NoteList where
  fmap f = NoteList . fromListH . map (fmap f) . toListH . getNoteList 

instance Monoid (NoteList pch) where
  mempty        = NoteList $ emptyH
  a `mappend` b = NoteList $ getNoteList a `appendH` getNoteList b

noteList :: NoteList pch
         -> (pch -> Event uctx z)
         -> EventList uctx ()
noteList nls noteF = 
    genNoteList nls $ \drn p -> aevent_ drn (noteF p)


noteListB1 :: NoteList pch
           -> Behavior b1
           -> (pch -> EventB1 b1 uctx z)
           -> EventList uctx ()
noteListB1 nls beh1 noteF = 
    genNoteList nls $ \drn p -> aeventB1 drn beh1 (noteF p)


noteListB2 :: NoteList pch
           -> Behavior b1 -> Behavior b2
           -> (pch -> EventB2 b1 b2 uctx z)
           -> EventList uctx ()
noteListB2 nls beh1 beh2 noteF = 
    genNoteList nls $ \drn p -> aeventB2 drn beh1 beh2 (noteF p)


noteListB3 :: NoteList pch
           -> Behavior b1 -> Behavior b2 -> Behavior b3
           -> (pch -> EventB3 b1 b2 b3 uctx z)
           -> EventList uctx ()
noteListB3 nls beh1 beh2 beh3 noteF = 
    genNoteList nls $ \drn p -> aeventB3 drn beh1 beh2 beh3 (noteF p)


noteListB4 :: NoteList pch
           -> Behavior b1 -> Behavior b2 -> Behavior b3
           -> Behavior b4
           -> (pch -> EventB4 b1 b2 b3 b4 uctx z)
           -> EventList uctx ()
noteListB4 nls beh1 beh2 beh3 beh4 noteF = 
    genNoteList nls $ \drn p -> aeventB4 drn beh1 beh2 beh3 beh4 (noteF p)


noteListB5 :: NoteList pch
           -> Behavior b1 -> Behavior b2 -> Behavior b3
           -> Behavior b4 -> Behavior b5
           -> (pch -> EventB5 b1 b2 b3 b4 b5 uctx z)
           -> EventList uctx ()
noteListB5 nls beh1 beh2 beh3 beh4 beh5 noteF = 
    genNoteList nls $ \drn p -> aeventB5 drn beh1 beh2 beh3 beh4 beh5 (noteF p)

genNoteList :: NoteList pch
            -> (Seconds -> pch -> Advance uctx z)
            -> EventList uctx ()
genNoteList nls advF = evalAdvance 0 $ bars $ toListH $ getNoteList nls
  where
    bars []                     = return ()
    bars (Bar bpm ns : xs)      = bar1 bpm ns >> bars xs
    
    bar1 _   []                 = return ()
    bar1 bpm (R d : ys)         = let d1 = beatToSeconds bpm d
                                  in advanceCursor d1 >> bar1 bpm ys

    bar1 bpm (N d p : ys)       = let d1 = beatToSeconds bpm d
                                  in advF d1 p >> bar1 bpm ys


noteListDuration :: NoteList pch -> Seconds
noteListDuration = bars 0 . toListH . getNoteList
  where
    bars ac []  = ac
    bars ac (Bar bpm ns : xs)   = let d1 = bar1 bpm 0 ns
                                  in bars (ac + d1) xs
    
    bar1 _   ac  []             = ac
    bar1 bpm ac (R d : ys)      = let d1 = beatToSeconds bpm d
                                  in bar1 bpm (ac + d1) ys

    bar1 bpm ac (N d _ : ys)    = let d1 = beatToSeconds bpm d
                                  in bar1 bpm (ac + d1) ys



type Note pch = Elt pch

bar :: BPM -> [Note pch] -> NoteList pch
bar bpm xs = NoteList $ wrapH b1
  where
    b1 = Bar { bar_bpm = bpm, bar_notes = xs }